home *** CD-ROM | disk | FTP | other *** search
/ Australian Personal Computer 2002 November / CD 1 / APC0211D1.ISO / workshop / prog / files / ActivePerl-5.6.1.633-MSWin32.msi / _f9e2db32ec02c4e467a369c92e15c39a < prev    next >
Encoding:
Text File  |  2002-05-30  |  12.1 KB  |  549 lines
  1. # Copyright (c) 1995-1999 Nick Ing-Simmons. All rights reserved.
  2. # This program is free software; you can redistribute it and/or
  3. # modify it under the same terms as Perl itself.
  4. package Tk::MMutil;
  5. use ExtUtils::MakeMaker;
  6. use Cwd;
  7. use Config;
  8. use Carp;
  9. use File::Basename;
  10.  
  11. use vars qw($VERSION);
  12. $VERSION = '3.050'; # $Id: //depot/Tk8/Tk/MMutil.pm#50 $
  13.  
  14. use Tk::MakeDepend;
  15.  
  16. use Tk::Config qw(!$VERSION);
  17. use vars qw($IsWin32);
  18.  
  19. *IsWin32 = \$main::IsWin32;
  20. $IsWin32 = ($^O eq 'MSWin32' || $Config{'ccflags'} =~ /-D_?WIN32_?/)
  21.            unless defined $IsWin32;
  22.  
  23. @MYEXPORT = qw(perldepend cflags const_config constants installbin c_o xs_o makefile manifypods);
  24.  
  25. sub arch_prune
  26. {
  27.  my $hash = shift;
  28.  foreach (keys %$hash)
  29.   {
  30.    if ($win_arch eq 'x')
  31.     {
  32.      delete $hash->{$_} if /Win[A-Z0-9]/ or /OS2/ or /ImgUtil/ or /^x/;
  33.     }
  34.    elsif ($win_arch eq 'open32')
  35.     {
  36.      delete $hash->{$_} if /Unix|Mwm/ and not /tclUnix/;
  37.      delete $hash->{$_} if /winMain|dllMain/;
  38.     }
  39.    elsif ($win_arch eq 'pm')
  40.     {
  41.      delete $hash->{$_}
  42.        if /Unix|Mwm/ and not
  43.      /tclUnix|Unix(3d|Button|Dialog|Color|Embed|Focus|Font|Menu|Scrlbr|Send|Int\.|Scale)/;
  44.      delete $hash->{$_} if /os2Main|dllMain|tkOS2Dll|^x(colors\.c|gc\.)/;
  45.      delete $hash->{$_} if /ImgUtil|tkWin[A-Z0-9]/ and not /OS2/;
  46.     }
  47.    elsif ($win_arch eq 'MSWin32')
  48.     {
  49.      delete $hash->{$_} if /Mwm/ and not /tclUnix/;
  50.      delete $hash->{$_} if /winMain|dllMain/;
  51.      # delete $hash->{$_} if /^Xrm/;
  52.     }
  53.   }
  54. }
  55.  
  56. sub mTk_postamble
  57. {
  58.  my ($self) = @_;
  59.  my $dep = "config :: \$(C_FILES) \$(H_FILES)\n\t$self->{NOECHO}\$(NOOP)\n";
  60.  my $mTk = $self->{'MTK'};
  61.  $dep .= "# Begin Munging dependancies\n";
  62.  foreach my $file (sort keys %$mTk)
  63.   {
  64.    $dep .= "$file : ".$mTk->{$file}." \$(TKDIR)/pTk/Tcl-pTk\n";
  65.    $dep .= "\t\$(PERL) \$(TKDIR)/pTk/Tcl-pTk ".$mTk->{$file}." $file\n";
  66.   }
  67.  $dep .= "# End Munging dependancies\n\n";
  68.  return $dep;
  69. }
  70.  
  71. sub mTk_CHO
  72. {
  73.  my $self = shift;
  74.  my $mTk  = shift;
  75.  my %c;
  76.  my %h;
  77.  foreach (@{$self->{H}}) { $h{$_} = 1 }
  78.  foreach (@{$self->{C}}) { $c{$_} = 1 }
  79.  foreach (keys %$mTk)
  80.   {
  81.    if (/\.c$/)
  82.     {
  83.      $c{$_} = 1;
  84.     }
  85.    elsif (/\.h$/)
  86.     {
  87.      $h{$_} = 1;
  88.     }
  89.   }
  90.  while (@_)
  91.   {
  92.    my $name = shift;
  93.    carp("No $name") unless (exists $c{$name});
  94.    delete $c{$name}
  95.   }
  96.  arch_prune(\%h);
  97.  arch_prune(\%c);
  98.  $self->{'H'}     = [sort keys %h];
  99.  $self->{'C'}     = [sort keys %c];
  100.  my(@o_files)     = @{$self->{C}};
  101.  $self->{O_FILES} = [grep s/\.c(pp|xx|c)?$/$self->{OBJ_EXT}/i, @o_files] ;
  102.  $self->{'MTK'}   = $mTk;
  103.  my $tk = installed_tk();
  104.  my $perl = $self->{'PERL'};
  105.  if ($IsWin32 && !-f $perl && -f "$perl.exe")
  106.   {
  107.    print "perl=$perl X=$^X\n";
  108.    $perl = "$perl.exe";
  109.    $self->{'PERL'} = $perl;
  110.   }
  111.  foreach my $file (sort keys %$mTk)
  112.   {
  113.    unless (-f $file)
  114.     {
  115.      warn "Extracting $file\n";
  116.      system($perl,"$tk/pTk/Tcl-pTk",$mTk->{$file},$file);
  117.     }
  118.   }
  119. }
  120.  
  121. my %visited;
  122.  
  123. sub abspath
  124. {
  125.  my $dir = shift;
  126.  my $here = getcwd() || die "Cannot get current directory:$!";
  127.  if (chdir($dir))
  128.   {
  129.    $dir = getcwd();
  130.    chdir($here) || die "Cannot cd back to $here:$!";
  131.   }
  132.  return $dir;
  133. }
  134.  
  135. sub relpath
  136. {
  137.  my ($path,$dir) = @_;
  138.  unless (defined $dir)
  139.   {
  140.    $dir = (-d $path) ? $path : dirname($path);
  141.   }
  142.  if (defined $dir and -d $dir)
  143.   {
  144.    if ($path =~ m#^\Q$dir\E([/\\]?.*)$#)
  145.     {
  146.      my $base  = $1;
  147.      my $here  = getcwd;
  148.      if ($here =~ m#^\Q$dir\E([/\\]?.*)#)
  149.       {
  150.        my $depth = reverse($1);
  151.        if ($depth)
  152.         {
  153.          $depth =~ s,[^/\\]+,..,g;
  154.         }
  155.        else
  156.         {
  157.          $depth = '.' ;
  158.         }
  159.        $depth =~ s,[/\\]+$,,;
  160.        $base =~ s,^[/\\]+,,;
  161.        $depth .= "/$base" if ($base);
  162.        if (-e $depth)
  163.         {
  164.          # print "$path is $depth from $here\n";
  165.          return $depth;
  166.         }
  167.        else
  168.         {
  169.          warn "Cannot find $depth\n";
  170.         }
  171.       }
  172.      else
  173.       {
  174.        unless(exists $visited{$here})
  175.         {
  176.          $visited{$here} = 1;
  177.          warn "$here does not start with $dir\n";
  178.          warn "i.e. building outside Tk itself\n";
  179.         }
  180.       }
  181.     }
  182.    else
  183.     {
  184.      die "'$path' not under '$dir'\n";
  185.     }
  186.   }
  187.  else
  188.   {
  189.    die "Cannot get directory for $path\n";
  190.   }
  191.  return $path;
  192. }
  193.  
  194. use strict;
  195.  
  196. sub upgrade_pic
  197. {
  198.  my $flags = '';
  199.  die 'upgrade_pic is obsolete';
  200.  return $flags;
  201. }
  202.  
  203. sub perldepend
  204. {
  205.  my $self = shift;
  206.  my $str = $self->MM::perldepend;
  207.  my $name;
  208.  my %c;
  209.  foreach my $file (@{$self->{'C'}})
  210.   {
  211.    $c{$file} = 1;
  212.   }
  213.  foreach my $file (keys %{$self->{'XS'}})
  214.   {
  215.    $c{$file} = 1;
  216.    delete $c{$self->{'XS'}{$file}};
  217.   }
  218.  my @files = grep(-f $_,sort(keys %c));
  219.  if (@files)
  220.   {
  221.    my $tk = installed_tk();
  222.    my @inc   = split(/\s+/,$self->{'INC'});
  223.    my @def   = split(/\s+/,$self->{'DEFINE'});
  224.    push(@def,qw(-DWIN32 -D__WIN32__)) if ($IsWin32);
  225.    if ($^O eq 'cygwin')
  226.     {
  227.      push(@def,qw(-D__CYGWIN__));
  228.      if ($win_arch eq 'MSWin32')
  229.       {
  230.        push(@def,qw(-D__WIN32__)) unless $self->{'DEFINE'} =~ /-D__WIN32__/;
  231.        push(@def,qw(-DWIN32)) if $self->{'NAME'} eq 'Tk::pTk';
  232.       }
  233.      elsif ($win_arch eq 'x')
  234.       {
  235.        push(@def,qw(-U_WIN32));
  236.       }
  237.     }
  238.    foreach (@inc)
  239.     {
  240.      s/\$\(TKDIR\)/$tk/g;
  241.      warn "Odd:$_" if /\$\(/;
  242.     }
  243.    $str .= Tk::MakeDepend::command_line(@inc,@def,@files) unless ($ENV{'TKNOMAKEDEPEND'});
  244.   }
  245.  return $str;
  246. }
  247.  
  248. sub const_config
  249. {
  250.  my $self = shift;
  251.  my $name;
  252.  foreach $name (grep /(%|\.(old|bak|q4|orig|rej))$/,keys %{$self->{PM}})
  253.   {
  254.    delete $self->{PM}->{$name};
  255.   }
  256.  my $flags = $self->{'CCCDLFLAGS'};
  257.  $flags =~ s/(-[fK]?\s*)pic\b/${1}PIC/;
  258.  $self->{'CCCDLFLAGS'} = $flags;
  259.  if ($^O eq 'MSWin32' && $Config{'ccflags'} =~ /-DPERL_OBJECT/)
  260.   {
  261.    $self->{'LDFLAGS'} =~ s/-(debug|pdb:\w+)\s+//g;
  262.    $self->{'LDDLFLAGS'} =~ s/-(debug|pdb:\w+)\s+//g;
  263.   }
  264.  elsif ($^O =~ /(openbsd)/i)
  265.   {
  266.    # -Bforcearchive is bad news for Tk - we don't want all of libpTk.a in all .so-s.
  267.    $self->{'LDDLFLAGS'} =~ s/-Bforcearchive\s*//g;
  268.   }
  269.  return $self->MM::const_config;
  270. }
  271.  
  272. sub constants
  273. {
  274.  my $self = shift;
  275.  local $_ = $self->MM::constants;
  276.  s/(\.SUFFIXES)/$1:\n$1/;
  277.  $_ .= "\nGCCOPT = $Tk::Config::gccopt\n";
  278.  if ($IsWin32)
  279.   {
  280.   }
  281.  $_;
  282. }
  283.  
  284. sub cflags
  285. {
  286.  my $self = shift;
  287.  local $_ = $self->MM::cflags;
  288.  if (0 && $IsWin32)
  289.   {
  290.    if ($Config::Config{cc} =~ /^bcc/i) {
  291.      # s/(CCFLAGS\s*=)/$1/;
  292.    }
  293.    else {
  294.      s/(CCFLAGS\s*=)/$1 \$(cflags) \$(cvarsdll)/;
  295.      s/(OPTIMIZE\s*=).*/$1 \$(cdebug)/;
  296.    }
  297.   }
  298.  $_;
  299. }
  300.  
  301. sub c_o
  302. {
  303.  my $self = shift;
  304.  local $_ = $self->MM::c_o;
  305.  s/\$\(DEFINE\)/\$(DEFINE) \$(GCCOPT)/g;
  306.  $_;
  307. }
  308.  
  309. sub xs_o
  310. {
  311.  my $self = shift;
  312.  local $_ = $self->MM::xs_o;
  313.  s/\$\(DEFINE\)/\$(DEFINE) \$(GCCOPT)/g;
  314.  $_;
  315. }
  316.  
  317. sub manifypods
  318. {
  319.  my $self = shift;
  320.  # Maybe always call UNIX version - we HTMLize them later
  321.  local $_ = $self->MM::manifypods;
  322.  if ($] >= 5.00565)
  323.   {
  324.    s/(POD2MAN_EXE.*pod2man)/$1 --center "perl\/Tk Documentation" --release "Tk\$(VERSION)"/;
  325.   }
  326.  elsif ($] >= 5.003)
  327.   {
  328.    s/(POD2MAN_EXE.*pod2man)/$1 -center "perl\/Tk Documentation" -release "Tk\$(VERSION)"/;
  329.   }
  330.  else
  331.   {
  332.    s/(POD2MAN_EXE.*pod2man)/$1 -center \\"perl\/Tk Documentation\\" -release \\"Tk\$(VERSION)\\"/;
  333.   }
  334.  s/\bpod::/Tk::/mg;
  335.  s/\bpTk:://mg;
  336.  $_;
  337. }
  338.  
  339. sub findINC
  340. {
  341.  my $file = shift;
  342.  my $dir;
  343.  foreach $dir (@INC)
  344.   {
  345.    my $try = "$dir/$file";
  346.    return $try if (-f $try);
  347.   }
  348.  die "Cannot find $file in \@INC\n";
  349. }
  350.  
  351.  
  352. sub makefile
  353. {
  354.  my $self = shift;
  355.  my $str  = $self->MM::makefile;
  356.  my $mm = findINC('Tk/MMutil.pm');
  357.  my $cf = findINC('Tk/Config.pm');
  358.  $str =~ s/(\$\(CONFIGDEP\))/$1 $cf $mm/;
  359.  $str =~ s/\$\(OBJECT\)\s*:.*\n//;
  360.  return $str;
  361. }
  362.  
  363. sub installed_tk
  364. {
  365.  my $tk;
  366.  my $dir;
  367.  foreach $dir (@INC)
  368.   {
  369.    if (-f "$dir/tkGlue.h")
  370.     {
  371.      $tk = relpath($dir);
  372.      last;
  373.     }
  374.    my $try = "$dir/Tk";
  375.    if (-f "$try/tkGlue.h")
  376.     {
  377.      $tk = relpath($try,$dir);
  378.      last;
  379.     }
  380.   }
  381.  die "Cannot find perl/Tk include files\n" unless (defined $tk);
  382.  $tk =~ s,^(\./)+,,;
  383.  return $tk;
  384. }
  385.  
  386. sub installbin
  387. {
  388.  my ($self) = @_;
  389.  my $str  = $self->MM::installbin;
  390.  my $prog = 'perl'; # $self->{'MAP_TARGET'} || 'perl';
  391.  my $inc  = findINC('Tk/MMutil.pm');
  392.  $inc =~ s,/Tk/MMutil.pm$,,;
  393.  $inc = relpath($inc);
  394.  $str =~ s/^\tcp\s/\t\$(PERL) -I$inc -MTk::install -e installbin $prog /mg;
  395.  return $str;
  396. }
  397.  
  398. sub findpTk
  399. {
  400.  my $ptk;
  401.  my $dir;
  402.  foreach $dir (map(abspath($_),@_),@INC)
  403.   {
  404.    my $try = "$dir/pTk";
  405.    if (-d $try && (-f "$try/Lang.h" || -f "$try/libpTk\$(LIB_EXT)"))
  406.     {
  407.      $ptk = relpath($try,$dir);
  408.      last;
  409.     }
  410.   }
  411.  confess "Cannot locate pTk\n" unless (defined $ptk);
  412.  return $ptk;
  413. }
  414.  
  415. sub find_subdir
  416. {
  417.  my %dir;
  418.  opendir(DIR,'.') || die "Cannot opendir:$!";
  419.  foreach my $dir (readdir(DIR))
  420.   {
  421.    next if $dir =~ /^\.\.?$/;
  422.    next if -l $dir;
  423.    next unless -d $dir;
  424.    if (-f "$dir/Makefile.PL")
  425.     {
  426.      my $exc = ($win_arch eq 'x') ? 'Unix' : 'Win';
  427.      if (-f "$dir/Not${exc}.exc")
  428.       {
  429.        warn "Skip $dir on $win_arch\n"
  430.       }
  431.      else
  432.       {
  433.        $dir{$dir} = 1
  434.       }
  435.     }
  436.   }
  437.  closedir(DIR);
  438.  return \%dir;
  439. }
  440.  
  441. sub TkExtMakefile
  442. {
  443.  my (%att) = @_;
  444.  if ($Config{'ccflags'} =~ /-DPERL_OBJECT/)
  445.   {
  446.    $att{'CAPI'} = 'TRUE' unless exists $att{'CAPI'};
  447.   }
  448.  unless (exists $att{'DIR'})
  449.   {
  450.    my $dir = find_subdir();
  451.    $att{'DIR'} = [sort(keys %$dir)];
  452.   }
  453.  unless (exists $att{'NAME'})
  454.   {
  455.    my $dir = getcwd;
  456.    my ($pack) = $dir =~ m#/([^/]+)$#;
  457.    if (defined $pack)
  458.     {
  459.      $att{NAME} = 'Tk::'.$pack;
  460.     }
  461.    else
  462.     {
  463.      warn "No Name and cannot deduce from '$dir'";
  464.     }
  465.   }
  466.  my $tk = installed_tk();
  467.  $att{'macro'} = {} unless (exists $att{'macro'});
  468.  $att{'macro'}{'TKDIR'} = $tk;
  469.  my @opt = ('VERSION'     => $Tk::Config::VERSION,
  470.             'XS_VERSION'  => $Tk::Config::VERSION);
  471.  push(@opt,'clean' => {} ) unless (exists $att{'clean'});
  472.  $att{'clean'}->{FILES} = '' unless (exists $att{'clean'}->{FILES});
  473.  $att{'clean'}->{FILES} .= ' *.bak';
  474.  unless (exists($att{'linkext'}) && $att{linkext}{LINKTYPE} eq '')
  475.   {
  476.    my $ptk = findpTk($tk);
  477.    my @tm = (findINC('Tk/typemap'));
  478.    unshift(@tm,@{$att{'TYPEMAPS'}}) if (exists $att{'TYPEMAPS'});
  479.    $att{'TYPEMAPS'} = \@tm;
  480.    my $i = delete ($att{'INC'});
  481.    $i = (defined $i) ? "$i $inc" : $inc;
  482.    if (delete $att{'dynamic_ptk'})
  483.     {
  484.      push(@opt,
  485.           'MYEXTLIB' => "$ptk/libpTk\$(LIB_EXT)",
  486. #         'dynamic_lib' => { INST_DYNAMIC_DEP => "$ptk/libpTk\$(LIB_EXT)" }
  487.          );
  488.     }
  489.    if ($IsWin32 && $Config{'cc'} =~ /^bcc/)
  490.     {
  491.      # Borland compiler is very dumb at finding files
  492.      $i = "-I$tk $i";
  493.      $i = "-I$ptk $i";
  494.     }
  495.    if ($IsWin32 && $Config{'cc'} =~ /^gcc/i)
  496.     {
  497.      my $base  = $Config{'libpth'};
  498.      $base =~ s#lib$#i386-mingw32/lib#;
  499.      my $extra = "-L$base -lcomdlg32 -lgdi32";
  500.      my $libs = $att{'LIBS'}->[0];
  501.      $att{'LIBS'}->[0] = "$extra $libs";
  502.     }
  503.    if ($^O eq 'cygwin')
  504.     {
  505.      # NOTE: use gcc -shared instead of dllwrap (ld2),
  506.      # dllwrap tries to resolve all symbols, even those
  507.      # that are brought in from libraries like libpTk.a
  508.      push(@opt,'LD' => 'gcc -shared');
  509.      if ($win_arch eq 'MSWin32')
  510.       {
  511.        my $extra = "-lcomdlg32 -lgdi32";
  512.        my $libs = $att{'LIBS'}->[0];
  513.        $att{'LIBS'}->[0] = "$extra $libs";
  514.        $att{'DEFINE'} .= ' -D__WIN32__';
  515.        $att{'DEFINE'} .= ' -DWIN32' if($att{'NAME'} eq 'Tk::pTk');
  516.       }
  517.      elsif ($win_arch eq 'x')
  518.       {
  519.        $att{'DEFINE'} .= ' -U_WIN32';
  520.       }
  521.     }
  522.    if (delete $att{'ptk_include'})
  523.     {
  524.      $i = "-I$ptk $i" unless ($ptk eq '.');
  525.     }
  526.    else
  527.     {
  528.      $i = "-I$tk $i" unless ($tk eq '.');
  529.     }
  530.    push(@opt,'DEFINE' => $define, 'INC' => $i);
  531.   }
  532.  WriteMakefile(@opt, %att);
  533. }
  534.  
  535. sub import
  536. {
  537.  no strict 'refs';
  538.  my $class = shift;
  539.  my @list = (@_) ? @_ : @{"${class}::MYEXPORT"};
  540.  my $name;
  541.  foreach $name (@list)
  542.   {
  543.    *{"MY::$name"} = \&{"$name"};
  544.   }
  545. }
  546.  
  547.  
  548. 1;
  549.